Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/pass32.fr_/pass32.fr

Text File | 1995-09-04 | 6KB | 205 lines

VERSION 4.00
Begin VB.Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Passworder"
   ClientHeight    =   2760
   ClientLeft      =   1080
   ClientTop       =   1515
   ClientWidth     =   4980
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   3165
   Left            =   1020
   LinkTopic       =   "Form1"
   ScaleHeight     =   2760
   ScaleWidth      =   4980
   Top             =   1170
   Width           =   5100
   Begin VB.CommandButton cmdClose
      Caption         =   "Cl&ose"
      Height          =   555
      Left            =   2520
      TabIndex        =   7
      Top             =   1920
      Width           =   1755
   End
   Begin VB.CommandButton cmdChangePwd
      Caption         =   "&Change Password"
      Height          =   555
      Left            =   480
      TabIndex        =   6
      Top             =   1920
      Width           =   1755
   End
   Begin VB.ComboBox cboUsers
      Height          =   300
      Left            =   2160
      Sorted          =   -1  'True
      Style           =   2  'Dropdown List
      TabIndex        =   5
      Top             =   360
      Width           =   2115
   End
   Begin VB.TextBox txtVerify
      Height          =   285
      Left            =   2160
      TabIndex        =   4
      Top             =   1320
      Width           =   2115
   End
   Begin VB.TextBox txtNew
      Height          =   285
      Left            =   2160
      TabIndex        =   3
      Top             =   840
      Width           =   2115
   End
   Begin VB.Label Label4
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Retype to verify:"
      Height          =   195
      Left            =   540
      TabIndex        =   2
      Top             =   1380
      Width           =   1425
   End
   Begin VB.Label Label3
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&New password:"
      Height          =   195
      Left            =   630
      TabIndex        =   1
      Top             =   900
      Width           =   1305
   End
   Begin VB.Label Label1
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&User:"
      Height          =   195
      Left            =   1410
      TabIndex        =   0
      Top             =   420
      Width           =   465
   End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private db As Database

Private Sub Form_Load()
    Dim myUser As String, myPass As String
    Dim i As Integer
    Dim winDir As String * 128
    Dim dirLen As Integer
    Dim dbName As String

    On Error GoTo LoadError

    ' Set the user and passwords for initial login.
    myUser = "Admin"
    myPass = "theboss"

    ' read VBDBHT.INI to get the name of the system database,
    ' then assign that name to the SystemDB property
    DBEngine.SystemDB = GetSystemDatabase()

    ' log in
    DBEngine.DefaultUser = myUser
    DBEngine.DefaultPassword = myPass

    ' Get the database name and open the database.
    dbName = DataPath() & "\CHAPTER.09\ORDERS.MDB" ' DataPath() is in READINI.BAS
    Set db = DBEngine.Workspaces(0).OpenDatabase(dbName)

    ' Fill the list box on the form.
    FillUserList

Exit Sub

LoadError:
    MsgBox Err.Description, vbCritical
End

End Sub

Sub FillUserList()
    Dim usr As User

    For Each usr In DBEngine.Workspaces(0).Users
        If UCase$(usr.Name) <> "CREATOR" And UCase$(usr.Name) <> "ENGINE" And UCase$(usr.Name) <> "ADMIN" Then
            cboUsers.AddItem usr.Name
        End If
    Next
End Sub

Private Sub cmdChangePwd_Click()
    Dim ws As Workspace

    On Error GoTo ChangeError

    If cboUsers.ListIndex = -1 Then Error 32765
    If txtNew = "" Then Error 32766
    If Len(txtNew) > 14 Then Error 32764
    If txtNew <> txtVerify Then Error 32767
    DBEngine.Workspaces(0).Users(cboUsers.Text).NewPassword "", txtNew
    MsgBox "Password changed for " & cboUsers.Text, vbInformation
    txtNew = ""
    txtVerify = ""
    cboUsers.ListIndex = -1
Exit Sub
ChangeError:
    Dim msg As String
    Select Case Err.Number
        Case 32764
            msg = "The password may not be longer than 14 characters"
            txtNew = ""
            txtVerify = ""
        Case 32765
            msg = "You have not selected a user"
        Case 32766
            msg = "You have not entered a new password"
        Case 32767
            msg = "The verify box does not match the new password box"
            txtNew = ""
            txtVerify = ""
        Case Else
            msg = Err.Description & " (" & Err.Number & ")"
    End Select
    MsgBox msg, vbExclamation
End Sub

Private Sub cmdClose_Click()
    End
End Sub
Private Function GetSystemDatabase() As String
    ' Returns the name of the system directory

    Const INI_FILENAME = "VBDBHT.INI"
    Const MAX_PATH = 128

    Dim lpReturnedString As String * MAX_PATH
    Dim bytesBack As Integer

    bytesBack = GetPrivateProfileString("Options", _
        "SystemDB", "", lpReturnedString, MAX_PATH, INI_FILENAME)
    GetSystemDatabase = IIf(bytesBack > 0, Left$(lpReturnedString, bytesBack), "")

End Function